home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / link / aem68suspend.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  4.1 KB  |  121 lines
  1. (herald aem68suspend (env tsys (link suspend)))
  2.  
  3. ;;; Look at image.doc and template.doc
  4. (define-local-syntax (dotimes spec . body)
  5.   (let ((index (car spec))
  6.         (limit (cadr spec)))
  7.     `(do ((,index 0 (fx+ ,index 1)))
  8.          ((fx= ,index ,limit))
  9.        ,@body)))
  10.  
  11.  
  12. (define (suspend obj out-spec x?)
  13.   (set (experimental?) x?)
  14.   (really-suspend obj out-spec 'image))
  15.  
  16. (define (vgc-foreign foreign)
  17.   (let ((desc (vgc-extend foreign 1 2)))
  18.     (push (lstate-foreign-reloc *lstate*)
  19.           (cons (symbol->string (foreign-name foreign))
  20.                 (fx+ (heap-offset desc) (fx* CELL 2))))
  21.     desc))
  22.  
  23. (define (generate-slot-relocation obj slot-address)
  24.   (cond ((or (fixnum? obj) (immediate? obj)))
  25.         (else                                               
  26.          (heap-reloc-thunk slot-address (vgc obj)))))
  27.  
  28. (define (text-relocation addr)
  29.   (push (lstate-text-reloc *lstate*) addr))
  30.  
  31. (define (data-relocation addr)
  32.   (push (lstate-data-reloc *lstate*) addr))
  33.  
  34.  
  35. (define (heap-reloc-thunk slot-address desc)
  36.   (if (eq? (heap-stored desc) (lstate-impure *lstate*))
  37.            (push (lstate-data-reloc *lstate*) slot-address)
  38.            (push (lstate-text-reloc *lstate*) slot-address)))
  39.    
  40.  
  41. (define (write-slot obj stream)
  42.   (cond ((fixnum? obj)
  43.          (write-fixnum stream obj))
  44.         ((immediate? obj)
  45.          (write-immediate stream obj))
  46.         ((null? obj)
  47.          (write-descriptor (lstate-null *lstate*) stream))
  48.         ((lp-table-entry (lstate-reloc *lstate*) obj)
  49.          => (lambda (desc) (write-descriptor desc stream)))
  50.         (else
  51.          (error "bad immediate type ~s" obj))))
  52.  
  53. (define-integrable (write-data stream int)
  54.   (write-int stream int))
  55.  
  56. (define-integrable (write-int stream int)
  57.   (write-half stream (fixnum-ashr int 16))
  58.   (write-half stream int))
  59.                        
  60. (define-integrable (write-immediate stream imm)
  61.   (let ((int (descriptor->fixnum imm)))
  62.     (write-half stream (fixnum-ashr int 14))
  63.     (write-half stream (fx+ (fixnum-ashl int 2) 1))))
  64.                                                      
  65. (define-integrable (write-scratch stream obj i)
  66.   (let ((offset (fixnum-ashl i 2)))
  67.     (write-half stream (mref-16-u obj offset))
  68.     (write-half stream (mref-16-u obj (fx+ offset 2)))))
  69.     
  70. (define-integrable (write-half stream int)
  71.   (vm-write-byte stream (fixnum-ashr int 8))
  72.   (vm-write-byte stream int))
  73.  
  74. ;(define-integrable (write-byte stream n)
  75. ;  (writec stream (ascii->char (fixnum-logand n 255))))
  76.  
  77. (define-integrable (write-fixnum stream fixnum)
  78.   (write-half stream (fixnum-ashr fixnum 14))
  79.   (write-half stream (fixnum-ashl fixnum 2)))
  80.  
  81. (define (write-link-file stream)
  82.   (write-header     stream)
  83.   (write-out-area   stream (lstate-pure *lstate*))
  84.   (write-out-area   stream (lstate-impure *lstate*))
  85.   (write-relocation stream (lstate-text-reloc *lstate*))
  86.   (write-relocation stream (lstate-data-reloc *lstate*))
  87.   (write-foreign-relocation stream (lstate-foreign-reloc *lstate*)))
  88.  
  89. (define (write-header stream)
  90.   (let* ((text-size (+area-frontier (lstate-pure *lstate*)))
  91.          (data-size (+area-frontier (lstate-impure *lstate*))))
  92.     (cond ((lp-table-entry (lstate-reloc *lstate*) big_bang)
  93.            => (lambda (desc)
  94.                 (write-descriptor desc stream)))  ; entry point
  95.           (else
  96.            (error "big_bang not defined")))
  97.     (write-int stream (fx* (length (lstate-text-reloc *lstate*)) 4))
  98.     (write-int stream (fx* (length (lstate-data-reloc *lstate*)) 4))
  99.     (write-int stream (foreign-reloc-size (lstate-foreign-reloc *lstate*)))
  100.     (write-int stream text-size)
  101.     (write-int stream data-size)))
  102.  
  103. (define (write-out-area stream area)
  104.   (walk (lambda (x) (write-store x stream))
  105.         (reverse! (+area-objects area))))
  106.  
  107. (define (write-relocation stream items)
  108.   (walk (lambda (addr) (write-int stream addr)) items))
  109.  
  110. (define (write-foreign-relocation stream syms)
  111.   (walk (lambda (sym)
  112.           (destructure (((name . addr) sym))
  113.             (write-int stream addr)
  114.             (vm-write-string stream name)
  115.             (dotimes (i (fx- 32 (string-length name)))
  116.               (vm-write-byte stream 32))))
  117.         syms))
  118.  
  119. (define (foreign-reloc-size syms)  ; syms are (name . addr)
  120.   (fx* (length syms) 36))
  121.